home *** CD-ROM | disk | FTP | other *** search
/ Light ROM 1 / LIGHT-ROM 1 (Amiga Library Services)(1994).iso / ffdisks / d963.lha / SIOD / scm / siod.scm < prev    next >
Text File  |  1993-07-09  |  14KB  |  445 lines
  1. ; Scheme In One Define.
  2. ; 
  3. ; The garbage collector, the name and other parts of this program are
  4. ;
  5. ; *                     COPYRIGHT (c) 1989 BY                              *
  6. ; *      PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  7. ;
  8. ; Conversion  to  full scheme standard, characters, vectors, ports, complex &
  9. ; rational numbers, debug utils, and other major enhancments by
  10. ;
  11. ; *      Scaglione Ermanno, v. Pirinoli 16 IMPERIA P.M. 18100 ITALY        * 
  12. ;
  13. ; Permission  to use, copy, modify, distribute and sell this software and its
  14. ; documentation  for  any purpose and without fee is hereby granted, provided
  15. ; that  the  above  copyright  notice appear in all copies and that both that
  16. ; copyright   notice   and   this  permission  notice  appear  in  supporting
  17. ; documentation,  and that the name of Paradigm Associates Inc not be used in
  18. ; advertising or publicity pertaining to distribution of the software without
  19. ; specific, written prior permission.
  20. ;
  21. ; Optional runtime library for version 2.0
  22.  
  23.  
  24. (define (caar x) (cxr x "aa"))
  25. (define (cadr x) (cxr x "da"))
  26. (define (cdar x) (cxr x "ad"))
  27. (define (cddr x) (cxr x "dd"))
  28.  
  29. (define (caaar x) (cxr x "aaa"))
  30. (define (caadr x) (cxr x "daa"))
  31. (define (cadar x) (cxr x "ada"))
  32. (define (caddr x) (cxr x "dda"))
  33.  
  34. (define (cdaar x) (cxr x "aad"))
  35. (define (cdadr x) (cxr x "dad"))
  36. (define (cddar x) (cxr x "add"))
  37. (define (cdddr x) (cxr x "ddd"))
  38.  
  39. (define (caaaar x) (cxr x "aaaa"))
  40. (define (caaadr x) (cxr x "daaa"))
  41. (define (caadar x) (cxr x "adaa"))
  42. (define (caaddr x) (cxr x "ddaa"))
  43.  
  44. (define (cadaar x) (cxr x "aada"))
  45. (define (cadadr x) (cxr x "dada"))
  46. (define (caddar x) (cxr x "adda"))
  47. (define (cadddr x) (cxr x "ddda"))
  48.  
  49. (define (cdaaar x) (cxr x "aaad"))
  50. (define (cdaadr x) (cxr x "daad"))
  51. (define (cdadar x) (cxr x "adad"))
  52. (define (cdaddr x) (cxr x "ddad"))
  53.  
  54. (define (cddaar x) (cxr x "aadd"))
  55. (define (cddadr x) (cxr x "dadd"))
  56. (define (cdddar x) (cxr x "addd"))
  57. (define (cddddr x) (cxr x "dddd"))
  58.  
  59. (macro freeze (lambda (x)
  60.                       (cons 'lambda 
  61.                             (cons nil (cdr x)))))
  62.  
  63. (define (thaw x) (x))
  64.  
  65. (macro delay (lambda (x)
  66.                  (list 'cons ''delayed-object
  67.                        (list 'lambda 
  68.                                    '() (cadr x)))))
  69.  
  70. (define (force x) 
  71.         (if (eq? (car x) 'memoized-object)
  72.             (cdr x) 
  73.             (sequence (set-cdr! x ((cdr x)))
  74.                       (set-car! x 'memoized-object)
  75.                       (cdr x))))
  76.  
  77. (define (delayed-object? x)
  78.         (if (pair? x)
  79.             (or (eq? (car x) 'delayed-object)(eq? (car x) 'memoized-object))
  80.             #f))
  81.  
  82. (macro cons-stream 
  83.        (lambda (x) 
  84.                (list 'cons
  85.                      (cadr x)
  86.                      (list 'delay (caddr x)))))
  87.  
  88. (define (head x) (car x))
  89.  
  90. (define (tail x) (force (cdr x)))
  91.  
  92. (define the-empty-stream 
  93.         ((named-lambda (empty-stream) 
  94.                        (cons-stream 'empty-stream (empty-stream)))))
  95.  
  96. (define (empty-stream? x) (eq? (head x) 'empty-stream))
  97.  
  98. (define (stream? x)
  99.         (and (pair? x) (delayed-object? (cdr x))))
  100.  
  101. (define (stream->list z)
  102.         (define (str->ls x y)
  103.                 (if (empty-stream? x)
  104.                     y
  105.                     (str->ls (tail x) (cons (head x) y))))
  106.          (str->ls z nil))  
  107.  
  108. (define (list->stream z)
  109.         (if (null? z)
  110.             the-empty-stream
  111.             (cons-stream (car z) (list->stream (cdr z)))))
  112.  
  113. (define (integer->string x) (number->string x '(int)))
  114.  
  115. (macro make-environment (lambda (x)
  116.                         (append (list 'let '())
  117.                                 (cdr x)
  118.                                 (list (list 'the-environment)))))
  119.  
  120. (macro alias (lambda (x) 
  121.                      (list 'define
  122.                            (cadr x) 
  123.                            (caddr x))))
  124.  
  125. (macro rec (lambda (x) 
  126.            (list 'letrec 
  127.                  (list (list (cadr x) 
  128.                              (caddr x)))
  129.                  (cadr x))))
  130.  
  131. (define (file-length x)
  132.         (let ((a (open-input-file x))
  133.               (b nil))
  134.              (set-file-position! a 0 2)
  135.              (set! b (get-file-position a))
  136.              (close-port a)
  137.              b))
  138.  
  139. (define (open-binary-input-file x) (open-port x "rb" 1))
  140.  
  141. (define (open-binary-output-port x) (open-port x "wb" 1))
  142.  
  143. (define (open-input-file x) (open-port x "r" 1))
  144.  
  145. (define (open-output-file x) (open-port x "w" 1))
  146.  
  147. (define (open-extend-file x) (open-port x "a" 1))
  148.  
  149. (define (current-input-port) (fluid input-port))
  150.  
  151. (define close-output-port close-port)
  152.  
  153. (define close-input-port close-port)
  154.  
  155. (define (current-output-port) (fluid output-port))
  156.  
  157. (define (flush-input x) (begin (read-line x) '()))
  158.  
  159. (define (newline . x) (display #\newline (car x)))
  160.  
  161. (define (page . x) (display #\page (car x)))
  162.  
  163. (define (call-with-input-file x y)
  164.         (let* ((in (open-input-file x))
  165.                (res (y in)))
  166.         (close-port in)
  167.         res))
  168.  
  169. (define (call-with-output-file x y)
  170.         (let* ((out (open-output-file x))
  171.                (res (y out)))
  172.         (close-port out)
  173.         res))
  174.  
  175. (define (with-input-from-file x y)
  176.         (let ((old-input (fluid input-port))
  177.               (res nil))
  178.              (set! (fluid input-port) (open-input-file x))
  179.              (set! res (y))
  180.              (close-port (fluid input-port))
  181.              (set! (fluid input-port) old-input)
  182.              res))
  183.  
  184. (define (with-output-to-file x y)
  185.         (let ((old-output (fluid output-port))
  186.               (res nil))
  187.              (set! (fluid output-port) (open-output-file x))
  188.              (set! res (y))
  189.              (close-port (fluid output-port))
  190.              (set! (fluid output-port) old-output)
  191.              res))
  192.  
  193. (define #\backspace (integer->char 8))
  194.  
  195. (define #\escape (integer->char 27))
  196.  
  197. (define #\newline (integer->char 10))
  198.  
  199. (define #\page (integer->char 12))
  200.  
  201. (define #\return (integer->char 13))
  202.  
  203. (define #\rubout (integer->char 63))
  204.  
  205. (define #\space (integer->char 32))
  206.  
  207. (define #\tab (integer->char 9))
  208.  
  209. (define (string<? x y)
  210.         (< (string-cmp x y) 0))        
  211.  
  212. (define (string>? x y)
  213.         (> (string-cmp x y) 0))
  214.  
  215. (define (string=? x y)
  216.         (= (string-cmp x y) 0))
  217.  
  218. (define (string<=? x y)
  219.         (<= (string-cmp x y) 0))
  220.  
  221. (define (string>=? x y)
  222.         (>= (string-cmp x y) 0))
  223.  
  224. (define (string-CI<? x y)
  225.         (< (string-cmp-CI x y) 0))        
  226.  
  227. (define (string-CI=? x y)
  228.         (= (string-cmp-CI x y) 0))
  229.  
  230. (define (substring-CI<? x y z a b c)
  231.         (string-ci<? (substring x y z) (substring a b c)))
  232.  
  233. (define (substring-CI=? x y z a b c)
  234.         (string-ci=? (substring x y z) (substring a b c)))
  235.  
  236. (define (substring<? x y z a b c)
  237.         (string<? (substring x y z) (substring a b c)))
  238.  
  239. (define (substring=? x y z a b c)
  240.         (string=? (substring x y z) (substring a b c)))
  241.  
  242. (define (string-null? x)
  243.         (= (string-cmp x "") 0))
  244.  
  245. (define (substring-fill! x y z a)
  246.         (while (< y z)
  247.                (string-set! x y a)
  248.                (set! y (1+ y)))
  249.         x)
  250.  
  251. (define (substring-move-left! x y z a b)
  252.         (while (< y z)
  253.                (string-set! x b (string-ref a y))
  254.                (set! b (1+ b))
  255.                (set! y (1+ y)))
  256.         x)
  257.  
  258. (define (substring-move-right! x y z a b)
  259.         (while (<= y z)
  260.                (set! z (-1+ z))
  261.                (string-set! x b (string-ref a z))
  262.                (set! b (1+ b)))
  263.         x)
  264.  
  265. (define (symbol->ASCII x) 
  266.         (char->integer (string-ref (symbol->string x) 0)))
  267.  
  268. (define (ASCII->symbol x)
  269.         (string->symbol (make-string 1 (integer->char x))))
  270.  
  271. (define (implode x)
  272.         (define y "")
  273.         (while (not (atom? x)) 
  274.                (cond ((string? (car x)) 
  275.                       (set! y (string-append y 
  276.                                      (make-string 1 (string-ref (car x) 0)))))
  277.                      ((symbol? (car x))
  278.                       (set! y (string-append y 
  279.                                      (make-string 1 (integer->char (symbol->ASCII (car x)))))))
  280.                      ((integer? (car x))
  281.                       (set! y (string-append y 
  282.                                      (make-string 1 (integer->char (car x))))))
  283.                      (else (error "arg to implode must be a symbol or a string or an integer" (car x))))
  284.                 (set! x (cdr x)))
  285.         (string->symbol y))
  286.                   
  287. (define (explode x)
  288.         (cond ((symbol? x) (set! x (symbol->string x)))
  289.               ((integer? x) (set! x (integer->string x)))
  290.               ((string? x))
  291.               (else (error "arg to explode must be a symbol or a string or an integer" x)))
  292.         (do ((i 0 (1+ i))
  293.              (res nil))
  294.             ((= i (string-length x)) (reverse! res))
  295.             (set! res 
  296.                   (cons (string->symbol (make-string 1 (string-ref x i)))
  297.                         res))))
  298.  
  299. (define (char<? x y)
  300.         (< (char-cmp x y) 0))   
  301.      
  302. (define (char>? x y)
  303.         (> (char-cmp x y) 0))
  304.                    
  305. (define (char=? x y)
  306.         (= (char-cmp x y) 0))
  307.  
  308. (define (char<=? x y)
  309.         (<= (char-cmp x y) 0))
  310.  
  311. (define (char>=? x y)
  312.         (>= (char-cmp x y) 0))
  313.  
  314. (define (char-ci<? x y)
  315.         (< (char-cmp (char-downcase x) (char-downcase y)) 0))   
  316.      
  317. (define (char-ci>? x y)
  318.         (> (char-cmp (char-downcase x) (char-downcase y)) 0))   
  319.      
  320. (define (char-ci=? x y)
  321.         (= (char-cmp (char-downcase x) (char-downcase y)) 0))   
  322.      
  323. (define (char-ci<=? x y)
  324.         (<= (char-cmp (char-downcase x) (char-downcase y)) 0))   
  325.      
  326. (define (char-ci>=? x y)
  327.         (>= (char-cmp (char-downcase x) (char-downcase y)) 0))   
  328.      
  329. (define (char-upper-case? x)
  330.         (and (char>=? x #\A) (char<=? x #\Z)))
  331.  
  332. (define (char-lower-case? x)
  333.         (and (char>=? x #\a) (char<=? x #\z)))
  334.  
  335. (define (char-digit? x)
  336.         (and (char>=? x #\0) (char<=? x #\9)))
  337.  
  338. (define (boolean? x) (or (eq? x #t) (eq? x #f)))
  339.  
  340. (define (edit)
  341.         (begin (dos-call "c:ed siod.tmp")
  342.                (load "siod.tmp")))
  343.  
  344. (define (ced)
  345.         (dos-call "ced"))
  346.  
  347. (define (call-with-current-continuation fcn)
  348.   (let ((tag (cons nil nil)))
  349.     (*catch tag
  350.        (fcn (lambda (value)
  351.          (*throw tag value))))))
  352.  
  353. (define call/cc call-with-current-continuation)
  354.  
  355. (define (sort! x . y)
  356.         (define test <=)
  357.         (define (interchange x i j)
  358.                 (define tmp (vector-ref x i))
  359.                 (vector-set! x i (vector-ref x j))
  360.                 (vector-set! x j tmp))
  361.         (define (qsort x m n)
  362.                 (if (< m n)
  363.                     (do ((i m) (j (1+ n))
  364.                          (k (begin (interchange x m (quotient (+ m n) 2))  
  365.                                    (vector-ref x m))))
  366.                         ((>= i j) (interchange x m j)
  367.                                   (qsort x m (-1+ j))
  368.                                   (qsort x (1+ j) n) x)
  369.                         (set! i (1+ i))
  370.                         (do () ((or (test k (vector-ref x i)) (>= i n)))
  371.                                (set! i (1+ i)))
  372.                         (set! j (-1+ j))
  373.                         (do () ((or (test (vector-ref x j) k) (<= j m)))
  374.                                (set! j (-1+ j)))
  375.                         (if (< i j) (interchange x i j)))))
  376.         (define (m-s x y)
  377.                 (define res (list 'dummy))
  378.                 (do ((ptr res (cdr ptr))
  379.                      (done #f))
  380.                     (done (cdr res))
  381.                     (cond ((null? x) (set-cdr! ptr y) (set! done #t))
  382.                           ((null? y) (set-cdr! ptr x) (set! done #t))
  383.                           ((test (car x) (car y))
  384.                            (set-cdr! ptr x) (set! x (cdr x)))
  385.                           (else (set-cdr! ptr y) (set! y (cdr y))))))
  386.         (define (mer-so x)
  387.                 (if (or (null? x) (null? (cdr x))) 
  388.                     x
  389.                     (m-s x (mer-so (do ((ptr (cdr x) (cdr ptr))
  390.                                         (y (cddr x) (cdr y)))
  391.                                        ((or (null? y) (test (car y) (car ptr))) 
  392.                                         (set-cdr! ptr nil) y))))))
  393.         (if (pair? y)
  394.             (if (proc? (car y))
  395.                 (set! test (car y))
  396.                 (error "second arg to sort! must be a procedure" (car y))))
  397.         (cond ((vector? x) (qsort x 0 (-1+ (vector-length x))) x)
  398.               ((pair? x) (mer-so x))
  399.               (else (error "first arg to sort! must be a vector or a list" x))))
  400.  
  401. (define (break proc . nome)
  402.         (let ((code (procedure-code proc))
  403.               (text (if (string? (car nome))
  404.                         (string-append "break-point entered in " (car nome))
  405.                         "breakpoint entered")))
  406.              (set-cdr! code (list 'begin 
  407.                                   (list 'bkpt text)
  408.                                   (cdr code)))
  409.              (set-procedure-code! proc code)))
  410.  
  411. (define (unbreak proc)
  412.         (let ((code (procedure-code proc)))
  413.              (if (eq? (caaddr code) 'bkpt)
  414.                  (set-cdr! code (cadddr code))
  415.                  (error "procedure is not breaked"))
  416.              (set-procedure-code! proc code)))
  417.  
  418. (define (*tracer* nome env)
  419.         (display (string-append "entering procedure " 
  420.                                 nome
  421.                                 " with parameters:"))
  422.         (do ((ar (environment-bindings env) (cdr ar))) 
  423.             ((null? ar)) 
  424.             (print (cdar ar))
  425.             (newline)))
  426.  
  427. (define (trace proc nome)
  428.         (let ((code (procedure-code proc)))
  429.              (set-cdr! code 
  430.                        (list 'begin 
  431.                              (list '*tracer* (if (string? (car nome)) 
  432.                                                  (car nome) 
  433.                                                  "")   
  434.                                              (list 'the-environment))
  435.                              (cdr code)))
  436.              (set-procedure-code! proc code)))
  437.  
  438. (define (untrace proc)
  439.         (let ((code (procedure-code proc)))
  440.              (if (eq? (caaddr code) '*tracer*)
  441.                  (set-cdr! code (cadddr code))
  442.                  (error "procedure is not traced"))
  443.              (set-procedure-code! proc code)))
  444.  
  445.